home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / smisc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  40.3 KB  |  1,411 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "setprots.h"
  13. #include "dbxprots.h"
  14. #include "arithprots.h"
  15. #include "chapprots.h"
  16. #include "dclmapprots.h"
  17. #include "miscprots.h"
  18. #include "smiscprots.h"
  19.  
  20. /* smisc.c: miscellaneous sem procedures needing semhdr.h */
  21. /* 
  22.  * 23-sep-85    ds
  23.  * add ast_clear to clear defined ast fields before resetting N_KIND.
  24.  *
  25.  * 11-jul-86    ACD
  26.  * modified the DEFINED fields for length clauses.  Previously only
  27.  * N_AST1 was recognized as being defined.  Now, both N_AST1 (the 
  28.  * attribute node) and N_AST2 ( the expression) are recognized
  29.  *
  30.  * 16-apr-85    ds
  31.  * add procedures fordeclared_1 and fordeclared_2. These are used to
  32.  * initialize and advance iteration over declared maps, and are 
  33.  * introduced to reduce the size of the FORDECLARED macro.
  34.  *
  35.  * 24-dec-84    ds
  36.  * have dcl_put NOT set visibility by default.
  37.  *
  38.  * 07-nov-84    ds
  39.  * have node_new_noseq set spans info.
  40.  * add spans_copy(new, old) to copy spans information from node old
  41.  * to node new.
  42.  *
  43.  * 04-nov-84    ds
  44.  * move undone() here as undone.c no longer needed.
  45.  *
  46.  * 02-nov-84    ds
  47.  * add attribute_str to return attribute name based on attribute
  48.  * code in N_VAL field of attribute node.
  49.  *
  50.  * 22-oct-84    ds
  51.  * add dcl_put_vis to enter with explicit visibility indication.
  52.  *
  53.  * 12-oct-84    ds
  54.  * merge in procedures formerly in dcl.c
  55.  */
  56.  
  57. static int const_cmp_kind(Const, Const);
  58.  
  59. void ast_clear(Node node)                                    /*;ast_clear*/
  60. {
  61.     int nk = N_KIND(node);
  62.     if (N_AST2_DEFINED(nk)) N_AST2(node) = (Node) 0;
  63.     if (N_AST3_DEFINED(nk)) N_AST3(node) = (Node) 0;
  64.     if (N_AST4_DEFINED(nk)) N_AST4(node) = (Node) 0;
  65. }
  66.  
  67. Const const_new(int k)                                        /*;const_new*/
  68. {
  69.     Const    result;
  70.  
  71.     result = (Const) smalloc(sizeof(Const_s));
  72.     result->const_kind = k;
  73.     result->const_value.const_int = 0; /* reasonable default value */
  74.     return result;
  75. }
  76.  
  77. Const int_const(int x)                                    /*;int_const*/
  78. {
  79.     Const    result;
  80.  
  81.     result = const_new(CONST_INT);
  82.     result->const_value.const_int = x;
  83.     return result;
  84. }
  85.  
  86. Const fixed_const(long x)                                /*;fixed_const*/
  87. {
  88.     Const    result;
  89.     result = const_new(CONST_FIXED);
  90.     result->const_value.const_fixed = x;
  91.     return result;
  92. }
  93.  
  94. Const uint_const(int *x)                                /*;uint_const*/
  95. {
  96.     Const    result;
  97.  
  98.     if (x == (int *)0) result = const_new(CONST_OM);
  99.     else {
  100.         result = const_new(CONST_UINT);
  101.         result->const_value.const_uint = x;
  102.     }
  103.     return result;
  104. }
  105.  
  106. Const real_const(double x)                                /*;real_const*/
  107. {
  108.     Const    result;
  109.  
  110.     result = const_new(CONST_REAL);
  111.     result->const_value.const_real = x;
  112.     return result;
  113. }
  114.  
  115. Const rat_const(Rational x)                                /*;rat_const*/
  116. {
  117.     Const    result;
  118.  
  119.     if (x == (Rational)0) result =  const_new(CONST_OM);
  120.     else {
  121.         result = const_new(CONST_RAT);
  122.         result->const_value.const_rat = x;
  123.     }
  124.     return result;
  125. }
  126.  
  127. /* Comparison functions for ivalues (Const's) */
  128.  
  129. int const_eq(Const const1, Const const2)                /*;const_eq*/
  130. {
  131.     /* checks to see if 2 Consts have the same value */
  132.  
  133.     switch (const_cmp_kind(const1, const2)) {
  134.     case CONST_OM:
  135.     case CONST_CONSTRAINT_ERROR:
  136.         return TRUE;
  137.     case CONST_INT:
  138.         return (INTV(const1) == INTV(const2));
  139.     case CONST_FIXED:
  140.         return (FIXEDV(const1) == FIXEDV(const2));
  141.     case CONST_UINT:
  142.         return int_eql(UINTV(const1), UINTV(const2));
  143.     case CONST_REAL:
  144.         return (RATV(const1) == RATV(const2));
  145.     case CONST_RAT:
  146.         return rat_eql(RATV(const1), RATV(const2));
  147.     case CONST_STR:
  148.         return streq(const1->const_value.const_str,
  149.           const2->const_value.const_str);
  150.     default:
  151.         return const_cmp_undef(const1, const2);
  152.     }
  153. }
  154.  
  155. int const_ne(Const cleft, Const cright)                        /*;const_ne*/
  156. {
  157.     return !const_eq(cleft, cright);
  158. }
  159.  
  160. int const_lt(Const cleft, Const cright)                        /*;const_lt*/
  161. {
  162.     switch (const_cmp_kind(cleft, cright)) {
  163.     case CONST_INT :
  164.         return (INTV(cleft)<INTV(cright));
  165.     case CONST_UINT :
  166.         return int_lss(UINTV(cleft), UINTV(cright));
  167.     case CONST_FIXED :
  168.         return (FIXEDV(cleft)<FIXEDV(cright));
  169.     case CONST_RAT :
  170.         return rat_lss(RATV(cleft), RATV(cright));
  171.     case CONST_REAL :
  172.         return  REALV(cleft) < REALV(cright);
  173.     default :
  174.         const_cmp_undef(cleft, cright);
  175.         return 0;
  176.     }
  177. }
  178.  
  179. int const_le(Const cleft, Const cright)                        /*;const_le*/
  180. {
  181.     return (const_eq(cleft, cright) || const_lt(cleft, cright));
  182. }
  183.  
  184. int const_gt(Const cleft, Const cright)                        /*;const_gt*/
  185. {
  186.     return const_lt(cright, cleft);
  187. }
  188.  
  189. int const_ge(Const cleft, Const cright)                        /*;const_ge*/
  190. {
  191.     return const_eq(cleft, cright) || const_lt(cright, cleft);
  192. }
  193.  
  194. static int const_cmp_kind(Const cleft, Const cright)        /*;const_cmp_kind*/
  195. {
  196.     int        ckind;
  197.  
  198.     ckind = cleft->const_kind;
  199.     if (ckind == CONST_OM) chaos("const comparison left operand not defined");
  200.     if (ckind != cright->const_kind) {
  201. #ifdef DEBUG
  202.         zpcon(cleft); 
  203.         zpcon(cright);
  204. #endif
  205.         chaos("const comparison operands differing kinds");
  206.     }
  207.     return ckind;
  208. }
  209.  
  210. int const_same_kind(Const cleft, Const cright)            /*;const_same_kind*/
  211. {
  212.     /* returns boolean value indicating whether two Consts are of same kind */
  213.     return (cleft->const_kind == cright->const_kind);
  214. }
  215.  
  216. int const_cmp_undef(Const cleft, Const cright)        /*;const_cmp_undef*/
  217. {
  218. #ifdef DEBUG
  219.     zpcon(cleft); 
  220.     zpcon(cright);
  221. #endif
  222.     chaos("const comparison not defined for these constant types");
  223.     return 0; /* for sake of lint */
  224. }
  225.  
  226. #define NODE_ALLOC
  227. /* define this to allocate several nodes at a time to avoid malloc
  228.  * overhead for each node. Note that when node_free used, will have to
  229.  * extend this to use linked list of nodes 
  230.  */
  231. #ifdef NODE_ALLOC
  232. static int nodes_avail = 0;
  233. static char *node_group;
  234. #define NODES_PER_GROUP (2048 / sizeof(Node_s))
  235. #endif
  236.  
  237. Node node_new_noseq(unsigned int na)                    /*;node_new_noseq*/
  238. {
  239.     char *np;
  240.     Node p;
  241.     int        i;
  242.  
  243. #ifdef NODE_ALLOC
  244.     if (nodes_avail == 0) {
  245.         node_group =  emalloct(NODES_PER_GROUP * sizeof(Node_s),
  246.           "node-group");
  247.         nodes_avail = NODES_PER_GROUP;
  248.     }
  249.     p = (Node) node_group;
  250.     node_group += sizeof(Node_s);
  251.     nodes_avail--;
  252. #else
  253.     p = (Node) ecalloct(1, sizeof(Node_s), "node-new");
  254. #endif
  255.     np = (char *) p;
  256.     /* clear all fields */
  257.     for (i = 0;i<sizeof(Node_s);i++) *np++ = 0;
  258.     N_KIND(p) = na;
  259.     return p;
  260. }
  261.  
  262. Node node_new(unsigned int na)                                    /*;node_new*/
  263. {
  264.     Node p;
  265.  
  266.     p = (Node) node_new_noseq(na);
  267.     if (seq_node_n > (int) seq_node[0]) 
  268.         chaos("node_new seq_node_n exceeds allocated length");
  269.     /* increment allocated count and assign sequence number for node*/
  270.     if(seq_node_n == (int) seq_node[0])
  271.         seq_node = tup_exp(seq_node, (unsigned)  seq_node_n+SEQ_NODE_INC);
  272.     seq_node_n += 1;
  273.     seq_node[seq_node_n] = (char *) p;
  274.     N_SEQ(p) = seq_node_n;
  275.     N_UNIT(p) = unit_number_now;
  276.     node_count += 1;
  277. #ifdef DEBUG
  278.     if (trapns>0 && N_SEQ(p) == trapns && N_UNIT(p) == trapnu) trapn(p);
  279. #endif
  280.     /* initialize other fields later */
  281.     return p;
  282. }
  283.  
  284. int fx_mantissa(Rational lbd, Rational ubd, Rational small)        /*;mantissa*/
  285. {
  286.     Rational exact_val;
  287.     int *vnum, *vden, *int_1;
  288.     int     power;
  289.  
  290.     lbd = rat_abs(lbd);
  291.     ubd = rat_abs(ubd);
  292.  
  293.     /*  find the exact # of values to be represented (aside from 0) */
  294.  
  295.     if (rat_gtr(lbd, ubd))
  296.         exact_val = rat_div(lbd, small);
  297.     else
  298.         exact_val = rat_div(ubd, small);
  299.     vnum = num(exact_val);
  300.     vden = den(exact_val);
  301.     int_1 = int_fri(1);
  302.  
  303.     /* the mantissa is calculated assuming that the bound is 'small away
  304.      * from a model number, so we subtract one before computing no. of bits
  305.      */
  306.  
  307.     vnum = int_sub(vnum, int_1);
  308.     vnum = int_quo(vnum, vden);
  309.     vden = int_fri(1);
  310.     power = 1;
  311.     while (int_gtr(vnum, vden)) {
  312.         power++;
  313.         vden = int_add(int_add(vden, vden), int_1);
  314.     }
  315.     return power;
  316. }
  317.  
  318. /* Not used */
  319. void node_free(Node node)                                    /*;node_free*/
  320. {
  321.     /* free nodeentry. Since state of allocated fields not clear
  322.      * only free the node block itself
  323.      */
  324.     chaos("node free");
  325.     if (node != (Node)0) efreet((char *) node, "node-free");
  326. }
  327.  
  328. void to_errfile(char *txt)                                    /*;to_errfile */
  329. {
  330.     printf("%s\n", txt);
  331. }
  332.  
  333. int needs_body(Symbol name)  /*;needs_body*/    
  334. {
  335.     /* Procedures and function specs need bodies of course. So do package
  336.      * specs that contain objects which need bodies.
  337.      */
  338.  
  339.     Symbol    obj;
  340.     char    *id;
  341.     Fordeclared    fd1;
  342.     int    nat;
  343.  
  344.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  needs_body");
  345.  
  346.     nat = NATURE(name);
  347.     if (nat == na_package_spec || nat == na_generic_package_spec) {
  348.         FORDECLARED(id, obj, DECLARED(name), fd1);
  349.             if (IS_VISIBLE(fd1) && obj->scope_of == name
  350.               && needs_body(obj)) return TRUE;
  351.         ENDFORDECLARED(fd1);
  352.         FORDECLARED(id, obj, DECLARED(name), fd1)
  353.             if (TYPE_OF(obj) == symbol_incomplete) return TRUE;
  354.         ENDFORDECLARED(fd1);
  355.         return FALSE;
  356.     }
  357.     if (nat == na_procedure_spec || nat == na_function_spec 
  358.       || nat == na_task_type_spec || nat == na_task_obj_spec
  359.       || nat == na_generic_procedure_spec || nat == na_generic_function_spec)
  360.         return TRUE;
  361.     return FALSE;
  362. }
  363.  
  364. /* The text of kind_str that follows is generated by a spitbol program
  365.  * called AS
  366.  */
  367. char *kind_str(unsigned int as)        /*;kind_str*/
  368. {
  369.     static char *as_names[] = {
  370.         "pragma",
  371.         "arg",
  372.         "obj_decl",
  373.         "const_decl",
  374.         "num_decl",
  375.         "type_decl",
  376.         "subtype_decl",
  377.         "subtype_indic",
  378.         "derived_type",
  379.         "range",
  380.         "range_attribute",
  381.         "constraint",
  382.         "enum",
  383.         "int_type",
  384.         "float_type",
  385.         "fixed_type",
  386.         "digits",
  387.         "delta",
  388.         "array_type",
  389.         "box",
  390.         "subtype",
  391.         "record",
  392.         "component_list",
  393.         "field",
  394.         "discr_spec",
  395.         "variant_decl",
  396.         "variant_choices",
  397.         "string",
  398.         "simple_choice",
  399.         "range_choice",
  400.         "choice_unresolved",
  401.         "others_choice",
  402.         "access_type",
  403.         "incomplete_decl",
  404.         "declarations",
  405.         "labels",
  406.         "character_literal",
  407.         "simple_name",
  408.         "call_unresolved",
  409.         "selector",
  410.         "all",
  411.         "attribute",
  412.         "aggregate",
  413.         "parenthesis",
  414.         "choice_list",
  415.         "op",
  416.         "in",
  417.         "notin",
  418.         "un_op",
  419.         "int_literal",
  420.         "real_literal",
  421.         "string_literal",
  422.         "null",
  423.         "name",
  424.         "qualify",
  425.         "new_init",
  426.         "new",
  427.         "statements",
  428.         "statement",
  429.         "null_s",
  430.         "assignment",
  431.         "if",
  432.         "cond_statements",
  433.         "condition",
  434.         "case",
  435.         "case_statements",
  436.         "loop",
  437.         "while",
  438.         "for",
  439.         "forrev",
  440.         "block",
  441.         "exit",
  442.         "return",
  443.         "goto",
  444.         "subprogram_decl",
  445.         "procedure",
  446.         "function",
  447.         "operator",
  448.         "formal",
  449.         "mode",
  450.         "subprogram",
  451.         "call",
  452.         "package_spec",
  453.         "package_body",
  454.         "private_decl",
  455.         "use",
  456.         "rename_obj",
  457.         "rename_ex",
  458.         "rename_pack",
  459.         "rename_sub",
  460.         "task_spec",
  461.         "task_type_spec",
  462.         "task",
  463.         "entry",
  464.         "entry_family",
  465.         "accept",
  466.         "delay",
  467.         "selective_wait",
  468.         "guard",
  469.         "accept_alt",
  470.         "delay_alt",
  471.         "terminate_alt",
  472.         "conditional_entry_call",
  473.         "timed_entry_call",
  474.         "abort",
  475.         "unit",
  476.         "with_use_list",
  477.         "with",
  478.         "subprogram_stub",
  479.         "package_stub",
  480.         "task_stub",
  481.         "separate",
  482.         "exception",
  483.         "except_decl",
  484.         "handler",
  485.         "others",
  486.         "raise",
  487.         "generic_function",
  488.         "generic_procedure",
  489.         "generic_package",
  490.         "generic_formals",
  491.         "generic_obj",
  492.         "generic_type",
  493.         "gen_priv_type",
  494.         "generic_subp",
  495.         "generic",
  496.         "package_instance",
  497.         "function_instance",
  498.         "procedure_instance",
  499.         "instance",
  500.         "length_clause",
  501.         "enum_rep_clause",
  502.         "rec_rep_clause",
  503.         "compon_clause",
  504.         "address_clause",
  505.         "any_op",
  506.         "opt",
  507.         "list",
  508.         "range_expression",
  509.         "arg_assoc_list",
  510.         "private",
  511.         "limited_private",
  512.         "code",
  513.         "line_no",
  514.         "index",
  515.         "slice",
  516.         "number",
  517.         "convert",
  518.         "entry_name",
  519.         "array_aggregate",
  520.         "record_aggregate",
  521.         "ecall",
  522.         "call_or_index",
  523.         "ivalue",
  524.         "qual_range",
  525.         "qual_index",
  526.         "qual_discr",
  527.         "qual_arange",
  528.         "qual_alength",
  529.         "qual_adiscr",
  530.         "qual_aindex",
  531.         "check_bounds",
  532.         "discr_ref",
  533.         "row",
  534.         "current_task",
  535.         "check_discr",
  536.         "end",
  537.         "terminate",
  538.         "exception_accept",
  539.         "test_exception",
  540.         "create_task",
  541.         "predef",
  542.         "deleted",
  543.         "insert",
  544.         "arg_convert",
  545.         "end_activation",
  546.         "activate_spec",
  547.         "delayed_type",
  548.         "qual_sub",
  549.         "static_comp",
  550.         "array_ivalue",
  551.         "record_ivalue",
  552.         "expanded",
  553.         "choices",
  554.         "init_call",
  555.         "type_and_value",
  556.         "discard",
  557.         "unread",
  558.         "string_ivalue",
  559.         "instance_tuple",
  560.         "entry_family_name",
  561.         "astend",
  562.         "astnull",
  563.         "aggregate_list",
  564.         "interfaced",
  565.         "record_choice",
  566.         "subprogram_decl_tr",
  567.         "subprogram_tr",
  568.         "subprogram_stub_tr",
  569.         "rename_sub_tr",
  570.         0    };
  571.     return (as <= 199) ? as_names[as] : "INVALID";
  572. }
  573.  
  574. /* following nature_str generated from spitbol program NA (on acf2) */
  575. char *nature_str(int na)                                /*;nature_str*/
  576. {
  577.     static char *na_names[] = {
  578.         "op",
  579.         "un_op",
  580.         "attribute",
  581.         "obj",
  582.         "constant",
  583.         "type",
  584.         "subtype",
  585.         "array",
  586.         "record",
  587.         "enum",
  588.         "literal",
  589.         "access",
  590.         "aggregate",
  591.         "block",
  592.         "procedure_spec",
  593.         "function_spec",
  594.         "procedure",
  595.         "function",
  596.         "in",
  597.         "inout",
  598.         "out",
  599.         "package_spec",
  600.         "package",
  601.         "task_type",
  602.         "task_type_spec",
  603.         "task_obj",
  604.         "task_obj_spec",
  605.         "entry",
  606.         "entry_family",
  607.         "entry_former",
  608.         "generic_procedure_spec",
  609.         "generic_function_spec",
  610.         "generic_package_spec",
  611.         "generic_procedure",
  612.         "generic_function",
  613.         "generic_package",
  614.         "exception",
  615.         "private_part",
  616.         "void",
  617.         "null",
  618.         "discriminant",
  619.         "field",
  620.         "label",
  621.         "generic_part",
  622.         "subprog",
  623.         "body",
  624.         "task",
  625.         "task_body",
  626.         0    };
  627.     return (na > 0 && na <= 48) ? na_names[na-1] : "INVALID";
  628. }
  629.  
  630. int in_open_scopes(Symbol s)                            /*;in_open_scopes*/
  631. {
  632.     return tup_mem((char *) s, open_scopes);
  633. }
  634.  
  635. char *newat_str()                                            /*newat_str*/
  636. {
  637.     static int n = 0;
  638.     char    *s;
  639.  
  640.     n += 1;
  641.     s = smalloc(6);
  642.     sprintf(s, "n%04d", n);
  643.     return s;
  644. }
  645.  
  646. char *str_newat()                                            /*;str_newat*/
  647. {
  648.     return newat_str();
  649. }
  650.  
  651. void symtab_copy(Symbol news, Symbol old)                        /*symtab_copy*/
  652. {
  653.     /* Note that this must be changed if symbol table layout changed */
  654.     /* called from ch3 */
  655.  
  656.     int nseq, nunit;
  657.  
  658.     nunit = S_UNIT(news);
  659.     nseq = S_SEQ(news);
  660.     sym_copy(news, old);
  661.     S_SEQ(news) = nseq;
  662.     S_UNIT(news) = nunit;
  663. }
  664.  
  665. void sym_copy(Symbol news, Symbol old)                        /*;sym_copy*/
  666. {
  667.     /* Note that this must be changed if symbol table layout changed */
  668.  
  669.     char    *op, *np;
  670.     int i, n;
  671.  
  672.     n = sizeof(Symbol_s);
  673.     op = (char *)old; 
  674.     np = (char *) news;
  675.     for (i = 1;i <= n;i++) *np++ = *op++;
  676. }
  677.  
  678. void SYMBTABcopy(Symbol news, Symbol old)                    /*SYMBATBcopy */
  679. {
  680.     /* copy symbol table fields referenced by (Setl) SYMBTAB macro, i.e.,
  681.      *    NATURE, TYPE_OF, SIGNATURE and OVERLOADS
  682.      * copies only pointers and not the structures pointed to by these pointers.
  683.      * thus, it may not be correct in the general case !
  684.      */
  685.  
  686.     NATURE(news) = NATURE(old);
  687.     TYPE_OF(news) = TYPE_OF(old);
  688.     SIGNATURE(news) = SIGNATURE(old);
  689.     OVERLOADS(news) = OVERLOADS(old);
  690.     /* what about a set_copy ?? */
  691. }
  692.  
  693. Symbol sym_new_noseq(int na)                            /*;sym_new_noseq*/
  694. {
  695.     /* allocate new symbol table entry, nature na */
  696.  
  697.     Symbol sym;
  698.  
  699.     sym = (Symbol) smalloc(sizeof(Symbol_s));
  700.     NATURE(sym) = na;
  701.     /* following not needed since allocate initially as zeros 
  702.      * ORIG_NAME(sym) = (char *)0;
  703.      * S_SEQ(sym) = 0; 
  704.      * S_UNIT(sym) = 0;
  705.      */
  706.     /* set SEGMENT to -1 to indicate not yet defined */
  707.     S_SEGMENT(sym) = -1;
  708.     return sym;
  709. }
  710.  
  711. Symbol sym_new(int na)                                        /*;sym_new*/
  712. {
  713.     /* allocate new symbol table entry, nature na.
  714.      * Increment sequence number and enter as sequence field of new entry 
  715.      *
  716.      */
  717.  
  718.     Symbol sym;
  719.  
  720.     sym = sym_new_noseq(na);
  721.     if (seq_symbol_n > (int) seq_symbol[0])
  722.          chaos("sym_new seq_symbol_n exceeds allocated length");
  723.     if (seq_symbol_n == (int)seq_symbol[0]) {
  724.         seq_symbol = tup_exp(seq_symbol,
  725.           (unsigned) (seq_symbol_n + SEQ_SYMBOL_INC));
  726.     }
  727.     seq_symbol_n += 1;
  728.     seq_symbol[seq_symbol_n] = (char *) sym;
  729.     S_SEQ(sym) = seq_symbol_n;
  730.     S_UNIT(sym) = unit_number_now; /* added by ds  2 dec 84*/
  731. #ifdef DEBUG
  732.     if (trapss>0 && S_SEQ(sym) == trapss && S_UNIT(sym) == trapsu) traps(sym);
  733. #endif
  734.     return sym;
  735. }
  736.  
  737. /* Not Used */
  738. int sym_free(Symbol sym)                                    /*;sym_free*/
  739. {
  740.     /* free symbol entry. Since state of allocated fields not clear
  741.      * only free the symbol block itself
  742.      */
  743.     return 0; /* do not free, use smalloc to allocate instead */
  744. #ifdef SKIP
  745.     if (sym != (Symbol)0) efreet((char *) sym, "sym-free");
  746. #endif
  747. }
  748.  
  749. /* procedures for private_declarations */
  750. Private_declarations private_decls_new(int n)        /*;private_decls_new*/
  751. {
  752.     Private_declarations    ps;
  753.     Tuple    t;
  754.  
  755.     ps = (Private_declarations) emalloct(sizeof(Private_declarations_s),
  756.       "private-declarations");
  757.     t = tup_new(n*2);
  758.     ps->private_declarations_tuple = t;
  759.     return ps;
  760. }
  761.  
  762. Symbol private_decls_get(Private_declarations pdecl, Symbol s)
  763.                                                     /*;private_decls_get*/
  764. {
  765.     Forprivate_decls    fp;
  766.     Symbol    s1, s2;
  767.  
  768.     if (s == (Symbol)0) return (Symbol)0;
  769.     FORPRIVATE_DECLS(s1, s2, pdecl, fp);
  770.         if (s1 == s) return s2;
  771.     ENDFORPRIVATE_DECLS(fp);
  772.     return    (Symbol)0;
  773. }
  774.  
  775. void private_decls_put(Private_declarations pdecl, Symbol s1)
  776.                                                     /*;private_decls_put*/
  777. {
  778.     int    i, n, newi = FALSE;
  779.     Tuple    t;
  780.     Symbol    s2;
  781.     Set    ovl;
  782.  
  783.     t = pdecl->private_declarations_tuple;
  784.     n = tup_size(t);
  785.     s2 = (Symbol)0;
  786.     for (i = 1;i <= n;i += 2) {
  787.         if (t[i] == (char *)s1) {
  788.             s2 = (Symbol) t[i+1]; /* if entry exists */
  789.             break;
  790.         }
  791.     }
  792.     if (s2 == (Symbol)0) { /* if need new entry */
  793.         newi = TRUE;
  794.         t = tup_exp(t, (unsigned) n+2);
  795.         pdecl->private_declarations_tuple = t;
  796.         t[n+1] = (char *)s1;
  797.         s2 = sym_new(NATURE(s1));
  798.         t[n+2] = (char *)s2;
  799.         /* TBSL: we need to copy signature and overloads when entering
  800.          * symbols with nature na_constant and na_type as these can have
  801.          * different representations in the private and public parts.
  802.          * ds 5-dec-84
  803.          */
  804.     }
  805.     /* if new entry, need to copy overloads (will always be a set) */
  806.     if (newi) {
  807.         /* now copy current information from s1 to s2 */
  808.         symtab_copy(s2, s1);
  809.         ovl = OVERLOADS(s1);
  810.         if (ovl != (Set)0)
  811.             OVERLOADS(s2) = set_copy(ovl);
  812.         /* also need to copy signature if private type */
  813.         if(TYPE_OF(s1) == symbol_private
  814.           || TYPE_OF(s1) == symbol_limited_private) {
  815.             if (SIGNATURE(s1) != (Tuple)0) {
  816.                 SIGNATURE(s2) = tup_copy(SIGNATURE(s1));
  817.                 if (declared_components(s2) != (Tuple) 0)
  818.                     SIGNATURE(s2)[4] =
  819.                       (char *) dcl_copy((Declaredmap)declared_components(s1));
  820.             }
  821.         }
  822.     }
  823. }
  824.  
  825. void private_decls_swap(Symbol s1, Symbol s2)        /*;private_decls_swap*/
  826. {
  827.     /* swap symbol table entries for s1 and s2 */
  828.  
  829.     struct Symbol_s tmp;
  830.     struct Symbol_s        *sp;
  831.     int        i, n, seq1, unit1, seq2, unit2;
  832.     char    *p1, *p2;
  833.  
  834.     /* this version assumes all symbol table entries of the same size */
  835.     p1 = (char *)s1;
  836.     sp = &tmp;
  837.     n = sizeof(Symbol_s);
  838.     /* copy s1 to tmp */
  839.     seq1 = S_SEQ(s1); 
  840.     unit1 = S_UNIT(s1);
  841.     seq2 = S_SEQ(s2); 
  842.     unit2 = S_UNIT(s2);
  843.     p1 = (char *)sp; 
  844.     p2 = (char *)s1;
  845.     for (i = 0;i<n;i++) *p1++ = *p2++;
  846.     /* copy s2 to s1 */
  847.     p1 = (char *)s1; 
  848.     p2 = (char *)s2;
  849.     for (i = 0;i<n;i++) *p1++ = *p2++;
  850.     /* copy tmp to s2 */
  851.     p1 = (char *)sp; 
  852.     p2 = (char *)s2;
  853.     for (i = 0;i<n;i++) *p2++ = *p1++;
  854.     /* restore original sequence numbers and units */
  855.     S_SEQ(s1) = seq1; 
  856.     S_UNIT(s1) = unit1;
  857.     S_SEQ(s2) = seq2; 
  858.     S_UNIT(s2) = unit2;
  859.     if (REPR(s1)==(Tuple)0) {
  860.        FORCED(s1) = FORCED(s2);
  861.        RCINFO(s1) = RCINFO(s2);
  862.        REPR(s1)   = REPR(s2);
  863.     } 
  864.     else if (REPR(s2)==(Tuple)0) {
  865.        FORCED(s2) = FORCED(s1);
  866.        RCINFO(s2) = RCINFO(s1);
  867.        REPR(s2)   = REPR(s1);
  868.     }
  869. }
  870.  
  871. char *attribute_str(int attrnum)                        /*;attribute_str*/
  872. {
  873.     /* convert internal attribute code to attribute string */
  874.  
  875.     static char *attrnames[] = { 
  876.         "ADDRESS", "AFT", "BASE", "CALLABLE",
  877.         "CONSTRAINED", "O_CONSTRAINED", "T_CONSTRAINED", "COUNT", "DELTA",
  878.         "DIGITS", "EMAX", "EPSILON", "FIRST", "O_FIRST", "T_FIRST", "FIRST_BIT",
  879.         "FORE", "IMAGE", "LARGE", "LAST", "O_LAST", "T_LAST", "LAST_BIT",
  880.         "LENGTH", "O_LENGTH", "T_LENGTH", "MACHINE_EMAX", "MACHINE_EMIN", 
  881.         "MACHINE_MANTISSA", "MACHINE_OVERFLOWS", "MACHINE_RADIX",
  882.         "MACHINE_ROUNDS", "MANTISSA", "POS", "POSITION", "PRED", "RANGE",
  883.         "O_RANGE", "T_RANGE", "SAFE_EMAX", "SAFE_LARGE", "SAFE_SMALL",
  884.         "SIZE", "O_SIZE", "T_SIZE", "SMALL", "STORAGE_SIZE", "SUCC", 
  885.         "TERMINATED", "VAL", "VALUE", "WIDTH", "any_attr"    };
  886.     /* i = (int) N_VAL(node);    pass code, not node (gcs) */
  887.  
  888.     if (attrnum > 52) chaos("attribute_str: invalid internal attriubte code");
  889.     return attrnames[attrnum];
  890. }
  891.  
  892. int no_dimensions(Symbol sym)                                /*;no_dimensions*/
  893. {
  894.     /* no_dimensions is macro defined in hdr.c */
  895.  
  896.     Tuple    tup = SIGNATURE(sym);
  897.     return tup_size((Tuple) tup[1]);
  898. }
  899.  
  900. int in_incp_types(Symbol s)                                    /*;in_incp_types*/
  901. {
  902.     return (s == symbol_private || s == symbol_limited_private)
  903.       || (s == symbol_limited) || (s == symbol_incomplete);
  904. }
  905.  
  906. int in_qualifiers(unsigned int kind)                        /*;in_qualifiers*/
  907. {
  908.     return (kind == as_qual_range || kind == as_qual_index
  909.       || kind == as_qual_discr || kind == as_qual_aindex
  910.       || kind == as_qual_adiscr);
  911. }
  912.  
  913. int in_univ_types(Symbol s)                                /*;in_univ_types*/
  914. {
  915.     return s == symbol_universal_real  || s == symbol_universal_integer;
  916. }
  917.  
  918. int in_vis_mods(Symbol v)                                    /*;in_vis_mods*/
  919. {
  920.     /* Test for membership in vis_mods. Assume vis_mods is tuple of symbols */
  921.     return tup_mem((char *) v, vis_mods);
  922. }
  923.  
  924. void undone(char *s)                                                /*;undone*/
  925. {
  926.     chaos(strjoin(s, " not implemented"));
  927. }
  928.  
  929. int is_type(Symbol name)                                         /*;is_type*/
  930. {
  931.     static int type_natures[8] = {
  932.         na_type, na_subtype, na_array, na_record, na_enum, na_access,
  933.         na_task_type, na_task_type_spec    };
  934.     int i;
  935.  
  936.     if (name == (Symbol)0) return FALSE;
  937.     for (i = 0; i < 8; i++)
  938.         if(NATURE(name) == type_natures[i]) return TRUE;
  939.     return FALSE;
  940. }
  941.  
  942. int is_fixed_type(Symbol typ)                                /*;is_fixed_type*/
  943. {
  944.     /* IS_FIXED_TYPE is procedure is_fixed_type() in C:
  945.      *   macro IS_FIXED_TYPE(typ);  (SIGNATURE(typ)(1) = co_delta)  endm;
  946.      */
  947.  
  948.     Tuple    tup;
  949.  
  950.     if (typ == symbol_dfixed) return TRUE;
  951.     tup = SIGNATURE(typ);
  952.     if (tup == (Tuple)0) return FALSE;
  953.     return tup[1] == (char *)CONSTRAINT_DELTA;
  954. }
  955.  
  956. int is_generic_type(Symbol type_mark)                    /*;is_generic_type*/
  957. {
  958.     int attr;
  959.  
  960.     attr = (int) misc_type_attributes(type_mark);
  961.     return    TA_GENERIC & attr;
  962. }
  963.  
  964. int is_access(Symbol name)                                    /*;is_access */
  965. {
  966.     /* TBSL: this appears identical to is_access_type in adagen and should be
  967.      * merged with it
  968.      */
  969.     if (name == (Symbol)0 || root_type(name) == (Symbol) 0)
  970.         return FALSE;
  971.     else return (NATURE((root_type(name))) == na_access);
  972. }
  973.  
  974. int is_scalar_type(Symbol name)                            /*;is_scalar_type*/
  975. {
  976.     Symbol    root;
  977.     Tuple   sig;
  978.  
  979.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_scalar_type");
  980.  
  981.     root = root_type(name);
  982.     /* if (root in scalar_types ...)
  983.      * ??const scalar_types =
  984.      *     {'INTEGER', 'FLOAT', '$FIXED', 'universal_integer', 'universal_real',
  985.      *      'universal_fixed', 'discrete_type'};
  986.      */
  987.     if (root == symbol_integer || root == symbol_float || root == symbol_dfixed
  988.       || root == symbol_universal_integer || root == symbol_universal_real
  989.       || root == symbol_universal_fixed || root == symbol_discrete_type )
  990.         return TRUE;
  991.     if (NATURE(root) == na_type) { /* fixed type also scalar */
  992.         sig = SIGNATURE(root);
  993.         if (sig != (Tuple)0 && (int) sig[1] == CONSTRAINT_DELTA) return TRUE;
  994.     }
  995.     return      NATURE(root) == na_enum;
  996. }
  997.  
  998. int is_numeric_type(Symbol typ)                            /*;is_numeric_type */
  999. {
  1000.     Symbol root;
  1001.  
  1002.     root = root_type (typ);
  1003.     return (root == symbol_integer || root == symbol_float
  1004.       || root == symbol_dfixed || root == symbol_universal_integer
  1005.       || root == symbol_universal_fixed || root == symbol_universal_real);
  1006. }
  1007.  
  1008. int is_record(Symbol typ)                                        /*;is_record*/
  1009. {
  1010.     /* This predicate is used to validate selected component notation and
  1011.      * the examination of discriminant lists.
  1012.      */
  1013.  
  1014.     Symbol    r;
  1015.  
  1016.     if (typ == (Symbol) 0) /* for case when typ = om in setl */
  1017.         return FALSE;
  1018.     if (NATURE(typ) == na_record) return TRUE;
  1019.     if (NATURE(typ) != na_subtype && NATURE(typ) != na_type) return FALSE;
  1020.     if (NATURE(base_type(typ)) == na_record) return TRUE;
  1021.     r = root_type(typ);
  1022.     if (in_incp_types(TYPE_OF(r)) && has_discriminants(r)) return TRUE;
  1023.     return FALSE;
  1024. }
  1025.  
  1026. int is_anonymous_task(Symbol name)                        /*;is_anonymous_task*/
  1027. {
  1028.     /* see if task anonymous (corresponds to macro of same name in SETL vern)*/
  1029.     /* Procedure task_spec (9) in SETL uses special prefix to flag anonymous
  1030.      * tasks. We simplify that to making the first character a colon 
  1031.      */
  1032.  
  1033.     char    *s;
  1034.     int        n;
  1035.  
  1036.     if (!is_task_type(name)) return FALSE;
  1037.     s = ORIG_NAME(name);
  1038.     if (s == (char *)0 ) return FALSE;
  1039.     s = substr(s, 1, 10);
  1040.     if (s == (char *)0) return FALSE;
  1041.     n = streq(s, "task_type:");
  1042. #ifndef SMALLOC
  1043.     efreet(s, "is-anonymous-task"); /* free temporary substring*/
  1044. #endif
  1045.     return n;
  1046. }
  1047.  
  1048. int is_task_type(Symbol task)                                /*;is_task_type*/
  1049. {
  1050.     return NATURE(task) == na_task_type || NATURE(task) == na_task_type_spec;
  1051. }
  1052.  
  1053. Node discr_map_get(Tuple dmap, Symbol sym)                /*;discr_map_get*/
  1054. {
  1055.     int        i, n;
  1056.  
  1057.     n = tup_size(dmap);
  1058.     for (i = 1;i <= n; i += 2)
  1059.         if ((Symbol) dmap[i]== sym) return (Node) dmap[i+1];
  1060.     return (Node)0;
  1061. }
  1062.  
  1063. Tuple discr_map_put(Tuple dmap, Symbol sym, Node nod)        /*;discr_map_put*/
  1064. {
  1065.     int        i, n;
  1066.  
  1067.     n = tup_size(dmap);
  1068.     for (i = 1;i <= n; i += 2) {
  1069.         if ((Symbol) dmap[i] == sym) {
  1070.             dmap[i+1] = (char *) nod;
  1071.             return dmap;
  1072.         }
  1073.     }
  1074.     dmap = tup_exp(dmap, (unsigned) n+2);
  1075.     dmap[n+1] = (char *) sym;
  1076.     dmap[n+2] = (char *) nod;
  1077.     return dmap;
  1078. }
  1079.  
  1080. int tup_memsym(Symbol sym, Tuple tp)                        /*;tup_memsym*/
  1081. {
  1082.     /* like tup_mem, but n is symbol, so also check for matching sequence and
  1083.      * unit number
  1084.      */
  1085.  
  1086.     int i;
  1087.     int sz;
  1088.  
  1089.     sz = tup_size(tp);
  1090.     for (i = 1;i <= sz;i++) {
  1091.         if ((Symbol)tp[i] == sym)
  1092.             return TRUE;
  1093.         if (S_SEQ((Symbol)tp[i]) == S_SEQ(sym)
  1094.           && S_UNIT((Symbol)tp[i]) == S_UNIT(sym))
  1095.             return TRUE;
  1096.     }
  1097.     return FALSE;
  1098. }
  1099.  
  1100. void const_check(Const con, int ctyp)                        /*;const_check*/
  1101. {
  1102.     /* check that const has const kind ctyp, raise chaos if not */
  1103.  
  1104.     if (con->const_kind == ctyp) return;
  1105. #ifdef DEBUG
  1106.     fprintf(stderr, "const of kind %d, expect %d\n", con->const_kind, ctyp);
  1107. #endif
  1108.     chaos("const not of expected kind");
  1109. }
  1110.  
  1111. int power_of_2(Const const_arg)                                /*;power_of_2*/
  1112. {
  1113.     /*
  1114.      * DESCR: This procedure finds the closest power of 2 <= the argument.
  1115.      * INPUT: arg:  a rational number.
  1116.      * OUTPUT: [accuracy, power, small]
  1117.      *        accuracy: 'exact' if arg= 2**power, or 'approximate'
  1118.      *                  if arg < 2**power.
  1119.      *        power: integer.
  1120.      *     small: rational value of 2**power
  1121.      * ALGORITHM:
  1122.      *    1- Work only with integers. So if num < den, invert the rational
  1123.      *          and remember.
  1124.      *    2- find first power such that den * 2**power >= num
  1125.      *    3- Adjust and negate if rational was inverted.
  1126.      *  4- Return zero if no errors, or one if cannot convert
  1127.      */
  1128.  
  1129.     Rational arg;
  1130.     int     *d, *n;        /* numerator and denominator of arg */
  1131.     int     inverted;        /* flag TRUE if arg < 1 */
  1132.     int     power;        /* the desired power of two */
  1133.     int    *next_power_of_2;    /* nearest power of 2 to given delta */
  1134.     int     *tmp;
  1135.  
  1136.     arg = RATV(const_arg);
  1137.     n = int_copy(num(arg));
  1138.     d = int_copy(den(arg));
  1139.  
  1140.     if (int_lss(n, d)) {
  1141.         tmp = n;
  1142.         n = d;
  1143.         d = tmp;
  1144.         inverted = TRUE;
  1145.     }
  1146.     else
  1147.         inverted = FALSE;
  1148.  
  1149.     power = 0;
  1150.     next_power_of_2 = int_fri(1);
  1151.     while(power < 127 && int_lss(int_mul(next_power_of_2, d), n)) {
  1152.         /* Should be possible to find  better algorithm.  */
  1153.         next_power_of_2 = int_mul(next_power_of_2, int_fri(2));
  1154.         power++;
  1155.     }
  1156.  
  1157.     if (int_eql(int_mul(next_power_of_2, d), n)) {
  1158.         power_of_2_accuracy = POWER_OF_2_EXACT;
  1159.         if (power == 127) power--;
  1160.         if (inverted) {
  1161.             power_of_2_power = -power;
  1162.             power_of_2_small = rat_fri(int_fri(1), next_power_of_2);
  1163.         }
  1164.         else {
  1165.             power_of_2_power = power;
  1166.             power_of_2_small = rat_fri(next_power_of_2, int_fri(1));
  1167.         }
  1168.     }
  1169.     else {
  1170.         power_of_2_accuracy = POWER_OF_2_APPROXIMATE;
  1171.         if (inverted) {
  1172.             if(power == 127) {
  1173.                 power_of_2_power = 126;
  1174.                 power_of_2_small = rat_fri(next_power_of_2, int_fri(1));
  1175.                 return 1;
  1176.             }
  1177.             power_of_2_power = -power;
  1178.             power_of_2_small = rat_fri(int_fri(1), next_power_of_2);
  1179.         }
  1180.         else {
  1181.             power_of_2_power = power - 1;
  1182.             power_of_2_small = rat_fri(next_power_of_2, int_fri(2));
  1183.         }
  1184.     }
  1185.     return 0;
  1186. }
  1187.  
  1188. Node new_ivalue_node(Const value, Symbol typ)            /*;new_ivalue_node*/
  1189. {
  1190.     /* constructs an ivalue node */
  1191.     Node    node;
  1192.  
  1193.     node         = node_new(as_ivalue);
  1194.     N_VAL (node) = (char *) value;
  1195.     N_TYPE(node) = typ;
  1196.     return node;
  1197. }
  1198.  
  1199. Tuple constraint_new(int ty)                            /*;constraint_new*/
  1200. {
  1201.     Tuple p;
  1202.     /* TBSL: set length correctly, make always five for now */
  1203.     p = tup_new(5);
  1204.     p[1] = (char *) ty;
  1205.  
  1206.     return p;
  1207. }
  1208.  
  1209. int N_DEFINED[] = {
  1210.     N_D_AST1 | N_D_AST2,                        /*   0 pragma */
  1211.     N_D_AST1 | N_D_AST2,                        /*   1 arg */
  1212.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*   2 obj_decl */
  1213.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*   3 const_decl */
  1214.     N_D_AST1 | N_D_AST2,                        /*   4 num_decl */
  1215.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*   5 type_decl */
  1216.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*   6 subtype_decl */
  1217.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*   7 subtype_indic */
  1218.     N_D_AST1,                                   /*   8 derived_type */
  1219.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*   9 range */
  1220.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  10 range_attribute */
  1221.     N_D_LIST,                                   /*  11 constraint */
  1222.     N_D_LIST,                                   /*  12 enum */
  1223.     N_D_AST1,                                   /*  13 int_type */
  1224.     N_D_AST1,                                   /*  14 float_type */
  1225.     N_D_AST1,                                   /*  15 fixed_type */
  1226.     N_D_AST1 | N_D_AST2,                        /*  16 digits */
  1227.     N_D_AST1 | N_D_AST2,                        /*  17 delta */
  1228.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*  18 array_type */
  1229.     N_D_AST1 | N_D_UNQ,                         /*  19 box */
  1230.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  20 subtype */
  1231.     N_D_AST1,                                   /*  21 record */
  1232.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  22 component_list */
  1233.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  23 field */
  1234.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  24 discr_spec */
  1235.     N_D_AST1 | N_D_AST2,                        /*  25 variant_decl */
  1236.     N_D_AST1 | N_D_AST2,                        /*  26 variant_choices */
  1237.     N_D_VAL,                                    /*  27 string */
  1238.     N_D_AST1,                                   /*  28 simple_choice */
  1239.     N_D_AST1,                                   /*  29 range_choice */
  1240.     N_D_AST1,                                   /*  30 choice_unresolved */
  1241.     N_D_AST1 | N_D_AST2,                        /*  31 others_choice */
  1242.     N_D_AST1,                                   /*  32 access_type */
  1243.     N_D_AST1,                                   /*  33 incomplete_decl */
  1244.     N_D_LIST,                                   /*  34 declarations */
  1245.     N_D_LIST,                                   /*  35 labels */
  1246.     N_D_VAL | N_D_TYPE,                         /*  36 character_literal */
  1247.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /*  37 simple_name */
  1248.     N_D_AST1 | N_D_AST2,                        /*  38 call_unresolved */
  1249.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  39 selector */
  1250.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /*  40 all */
  1251.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  41 attribute */
  1252.     N_D_LIST | N_D_TYPE,                        /*  42 aggregate */
  1253.     N_D_AST1 | N_D_TYPE,                        /*  43 parenthesis */
  1254.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  44 choice_list */
  1255.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  45 op */
  1256.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  46 in */
  1257.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  47 notin */
  1258.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  48 un_op */
  1259.     N_D_VAL | N_D_TYPE,                         /*  49 int_literal */
  1260.     N_D_VAL | N_D_TYPE,                         /*  50 real_literal */
  1261.     N_D_VAL | N_D_TYPE,                         /*  51 string_literal */
  1262.     N_D_TYPE,                                   /*  52 null */
  1263.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /*  53 name */
  1264.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  54 qualify */
  1265.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  55 new_init */
  1266.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  56 new */
  1267.     N_D_AST1 | N_D_AST2,                        /*  57 statements */
  1268.     N_D_AST1 | N_D_AST2,                        /*  58 statement */
  1269.     0,                                          /*  59 null_s */
  1270.     N_D_AST1 | N_D_AST2,                        /*  60 assignment */
  1271.     N_D_AST1 | N_D_AST2,                        /*  61 if */
  1272.     N_D_AST1 | N_D_AST2,                        /*  62 cond_statements */
  1273.     N_D_AST1,                                   /*  63 condition */
  1274.     N_D_AST1 | N_D_AST2,                        /*  64 case */
  1275.     N_D_AST1 | N_D_AST2,                        /*  65 case_statements */
  1276.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  66 loop */
  1277.     N_D_AST1,                                   /*  67 while */
  1278.     N_D_AST1 | N_D_AST2,                        /*  68 for */
  1279.     N_D_AST1 | N_D_AST2,                        /*  69 forrev */
  1280.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  70 block */
  1281.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*  71 exit */
  1282.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  72 return */
  1283.     N_D_AST1,                                   /*  73 goto */
  1284.     N_D_AST1,                                   /*  74 subprogram_decl */
  1285.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  75 procedure */
  1286.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  76 function */
  1287.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /*  77 operator */
  1288.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  78 formal */
  1289.     N_D_VAL,                                    /*  79 mode */
  1290.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  80 subprogram */
  1291.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  81 call */
  1292.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  82 package_spec */
  1293.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  83 package_body */
  1294.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  84 private_decl */
  1295.     N_D_LIST,                                   /*  85 use */
  1296.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  86 rename_obj */
  1297.     N_D_AST1 | N_D_AST2,                        /*  87 rename_ex */
  1298.     N_D_AST1 | N_D_AST2,                        /*  88 rename_pack */
  1299.     N_D_AST1 | N_D_AST2,                        /*  89 rename_sub */
  1300.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  90 task_spec */
  1301.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  91 task_type_spec */
  1302.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  92 task */
  1303.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  93 entry */
  1304.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  94 entry_family */
  1305.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  95 accept */
  1306.     N_D_AST1,                                   /*  96 delay */
  1307.     N_D_AST1 | N_D_AST2,                        /*  97 selective_wait */
  1308.     N_D_AST1 | N_D_AST2,                        /*  98 guard */
  1309.     N_D_AST1 | N_D_AST2,                        /*  99 accept_alt */
  1310.     N_D_AST1 | N_D_AST2,                        /* 100 delay_alt */
  1311.     N_D_VAL,                                    /* 101 terminate_alt */
  1312.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 102 conditional_entry_call */
  1313.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 103 timed_entry_call */
  1314.     N_D_LIST,                                   /* 104 abort */
  1315.     N_D_AST1 | N_D_AST2,                        /* 105 unit */
  1316.     N_D_LIST,                                   /* 106 with_use_list */
  1317.     N_D_LIST,                                   /* 107 with */
  1318.     N_D_AST1 | N_D_VAL,                         /* 108 subprogram_stub */
  1319.     N_D_VAL | N_D_UNQ,                          /* 109 package_stub */
  1320.     N_D_VAL | N_D_UNQ,                          /* 110 task_stub */
  1321.     N_D_AST1 | N_D_AST2,                        /* 111 separate */
  1322.     N_D_LIST,                                   /* 112 exception */
  1323.     N_D_LIST,                                   /* 113 except_decl */
  1324.     N_D_AST1 | N_D_AST2,                        /* 114 handler */
  1325.     0,                                          /* 115 others */
  1326.     N_D_AST1 | N_D_TYPE,                        /* 116 raise */
  1327.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 117 generic_function */
  1328.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 118 generic_procedure */
  1329.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 119 generic_package */
  1330.     N_D_LIST,                                   /* 120 generic_formals */
  1331.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 121 generic_obj */
  1332.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 122 generic_type */
  1333.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 123 gen_priv_type */
  1334.     N_D_AST1 | N_D_AST2,                        /* 124 generic_subp */
  1335.     0,                                          /* 125 generic */
  1336.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 126 package_instance */
  1337.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 127 function_instance */
  1338.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 128 procedure_instance */
  1339.     N_D_AST1 | N_D_AST2,                        /* 129 instance */
  1340.     N_D_AST1 | N_D_AST2,                        /* 130 length_clause */
  1341.     N_D_AST1 | N_D_AST2,                        /* 131 enum_rep_clause */
  1342.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 132 rec_rep_clause */
  1343.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 133 compon_clause */
  1344.     N_D_AST1,                                   /* 134 address_clause */
  1345.     N_D_AST1,                                   /* 135 any_op */
  1346.     0,                                          /* 136 opt */
  1347.     N_D_LIST,                                   /* 137 list */
  1348.     N_D_AST1 | N_D_UNQ,                         /* 138 range_expression */
  1349.     N_D_LIST,                                   /* 139 arg_assoc_list */
  1350.     N_D_AST1,                                   /* 140 private */
  1351.     N_D_AST1,                                   /* 141 limited_private */
  1352.     N_D_AST1,                                   /* 142 code */
  1353.     N_D_VAL,                                    /* 143 line_no */
  1354.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 144 index */
  1355.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 145 slice */
  1356.     N_D_VAL,                                    /* 146 number */
  1357.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 147 convert */
  1358.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 148 entry_name */
  1359.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /* 149 array_aggregate */
  1360.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /* 150 record_aggregate */
  1361.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 151 ecall */
  1362.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 152 call_or_index */
  1363.     N_D_VAL | N_D_TYPE,                         /* 153 ivalue */
  1364.     N_D_AST1 | N_D_TYPE,                        /* 154 qual_range */
  1365.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 155 qual_index */
  1366.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 156 qual_discr */
  1367.     N_D_AST1,                                   /* 157 qual_arange */
  1368.     N_D_AST1,                                   /* 158 qual_alength */
  1369.     N_D_AST1 | N_D_TYPE,                        /* 159 qual_adiscr */
  1370.     N_D_AST1 | N_D_TYPE,                        /* 160 qual_aindex */
  1371.     N_D_AST1 | N_D_AST2,                        /* 161 check_bounds */
  1372.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 162 discr_ref */
  1373.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 163 row */
  1374.     N_D_UNQ,                                    /* 164 current_task */
  1375.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 165 check_discr */
  1376.     N_D_AST1,                                   /* 166 end */
  1377.     N_D_AST1 | N_D_VAL,                         /* 167 terminate */
  1378.     N_D_AST1,                                   /* 168 exception_accept */
  1379.     N_D_AST1,                                   /* 169 test_exception */
  1380.     N_D_AST1 | N_D_TYPE,                        /* 170 create_task */
  1381.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /* 171 predef */
  1382.     0,                                          /* 172 deleted */
  1383.     N_D_AST1 | N_D_LIST | N_D_TYPE,             /* 173 insert */
  1384.     N_D_AST1,                                   /* 174 arg_convert */
  1385.     N_D_AST1 | N_D_VAL,                         /* 175 end_activation */
  1386.     N_D_AST1,                                   /* 176 activate_spec */
  1387.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 177 delayed_type */
  1388.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 178 qual_sub */
  1389.     N_D_AST1 | N_D_AST2,                        /* 179 static_comp */
  1390.     N_D_AST1 | N_D_AST2,                        /* 180 array_ivalue */
  1391.     N_D_AST1 | N_D_AST2,                        /* 181 record_ivalue */
  1392.     N_D_AST1,                                   /* 182 expanded */
  1393.     N_D_AST1,                                   /* 183 choices */
  1394.     N_D_AST1 | N_D_AST2,                        /* 184 init_call */
  1395.     N_D_AST1 | N_D_AST2,                        /* 185 type_and_value */
  1396.     N_D_AST1,                                   /* 186 discard */
  1397.     N_D_AST1,                                   /* 187 unread */
  1398.     N_D_VAL | N_D_TYPE,                         /* 188 string_ivalue */
  1399.     N_D_VAL,                                    /* 189 instance_tuple */
  1400.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 190 entry_family_name */
  1401.     0,                                          /* 191 astend */
  1402.     0,                                          /* 192 astnull */
  1403.     N_D_AST1 | N_D_AST2,                        /* 193 aggregate_list */
  1404.     N_D_AST1 | N_D_UNQ,                         /* 194 interfaced */
  1405.     N_D_AST1 | N_D_AST2,                        /* 195 record_choice */
  1406.     N_D_UNQ,                                    /* 196 subprogram_decl_tr */
  1407.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_AST4,   /* 197 subprogram_tr */
  1408.     N_D_VAL | N_D_UNQ,                          /* 198 subprogram_stub_tr */
  1409.     N_D_AST2 | N_D_UNQ,                         /* 199 rename_sub_tr */
  1410.     0};
  1411.